home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlprin.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  10.5 KB  |  420 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlprint.c
  5. * RCS:          $Header: xlprin.c,v 1.8 91/03/24 22:25:20 mayer Exp $
  6. * Description:  xlisp print routine
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:09:03 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlprin.c,v 1.8 91/03/24 22:25:20 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. #ifdef WINTERP
  48. extern LVAL Wres_Get_Symbol();    /* w_resources.c */
  49. #endif
  50.  
  51. /* external variables */
  52. extern LVAL tentry();
  53. extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
  54. extern LVAL s_ifmt,s_ffmt;
  55. extern FUNDEF funtab[];
  56. extern char buf[];
  57.  
  58. /* xlprint - print an xlisp value */
  59. xlprint(fptr,vptr,flag)
  60.   LVAL fptr,vptr; int flag;
  61. {
  62.     LVAL nptr,next;
  63.     int n,i;
  64.  
  65.     /* print nil */
  66.     if (vptr == NIL) {
  67.     putsymbol(fptr,"NIL",flag);
  68.     return;
  69.     }
  70.  
  71.     /* check value type */
  72.     switch (ntype(vptr)) {
  73.     case SUBR:
  74.         putsubr(fptr,"Subr",vptr);
  75.         break;
  76.     case FSUBR:
  77.         putsubr(fptr,"FSubr",vptr);
  78.         break;
  79.     case CONS:
  80.         xlputc(fptr,'(');
  81.         for (nptr = vptr; nptr != NIL; nptr = next) {
  82.             xlprint(fptr,car(nptr),flag);
  83.         if (next = cdr(nptr))
  84.             if (consp(next))
  85.             xlputc(fptr,' ');
  86.             else {
  87.             xlputstr(fptr," . ");
  88.             xlprint(fptr,next,flag);
  89.             break;
  90.             }
  91.         }
  92.         xlputc(fptr,')');
  93.         break;
  94.     case SYMBOL:
  95.         putsymbol(fptr,getstring(getpname(vptr)),flag);
  96.         break;
  97.     case FIXNUM:
  98.         putfixnum(fptr,getfixnum(vptr));
  99.         break;
  100.     case FLONUM:
  101.         putflonum(fptr,getflonum(vptr));
  102.         break;
  103.     case CHAR:
  104.         putchcode(fptr,getchcode(vptr),flag);
  105.         break;
  106.     case STRING:
  107.         if (flag)
  108.         putqstring(fptr,vptr);
  109.         else
  110.         putstring(fptr,vptr);
  111.         break;
  112.     case STREAM:
  113.         putatm(fptr,"File-Stream",vptr);
  114.         break;
  115.     case USTREAM:
  116.         putatm(fptr,"Unnamed-Stream",vptr);
  117.         break;
  118.     case OBJECT:
  119.         putatm(fptr,"Object",vptr);
  120.         break;
  121.     case VECTOR:
  122.         xlputc(fptr,'#'); xlputc(fptr,'(');
  123.         for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
  124.         xlprint(fptr,getelement(vptr,i),flag);
  125.         if (i != n) xlputc(fptr,' ');
  126.         }
  127.         xlputc(fptr,')');
  128.         break;
  129.     case STRUCT:
  130.         xlprstruct(fptr,vptr,flag);
  131.         break;
  132.     case CLOSURE:
  133.         putclosure(fptr,vptr);
  134.         break;
  135.     case FREE:
  136.         putatm(fptr,"Free",vptr);
  137.         break;
  138.  
  139. #ifdef WINTERP
  140.     case XLTYPE_XtAccelerators:
  141.         putatm(fptr, "XtAccelerators", vptr);
  142.         break;
  143.     case XLTYPE_XtTranslations:
  144.         putatm(fptr, "XtTranslations", vptr);
  145.         break;
  146.     case XLTYPE_XEvent:
  147.         putatm(fptr, "XEvent", vptr);
  148.         break;
  149.     case XLTYPE_Window:
  150.         putatm(fptr, "Window", vptr);
  151.         break;
  152.     case XLTYPE_Pixel:
  153.         putatm(fptr, "Pixel", vptr);
  154.         break;
  155.     case XLTYPE_Pixmap:
  156.         putatm(fptr, "Pixmap", vptr);
  157.         break;
  158.     case XLTYPE_XImage:
  159.         putatm(fptr, "XImage", vptr);
  160.         break;
  161.     case XLTYPE_XmString:
  162.         putatm(fptr, "XmString", vptr);
  163.         break;
  164.     case XLTYPE_XT_RESOURCE:
  165.         putsymbol(fptr,
  166.               getstring(getpname(Wres_Get_Symbol(vptr))),
  167.               flag);
  168.         break;
  169.     case XLTYPE_CALLBACKOBJ:
  170.         putatm(fptr, "CALLBACK-OBJ", vptr);
  171.         break;
  172.     case XLTYPE_TIMEOUTOBJ:
  173.         putatm(fptr, "TIMEOUT-OBJ", vptr);
  174.         break;
  175.     case XLTYPE_PIXMAP_REFOBJ:
  176.         putatm(fptr, "PIXMAP-REFOBJ", vptr);
  177.         break;
  178.     case XLTYPE_WIDGETOBJ:
  179.         Wcls_Print_WIDGETOBJ(fptr, vptr); /* from w_classes.c */
  180.         break;
  181.     case XLTYPE_EVHANDLEROBJ:
  182.         putatm(fptr, "EVHANDLER-OBJ", vptr);
  183.         break;
  184. #endif                /* WINTERP */
  185.  
  186. #if (defined(UNIX) || defined(WINTERP))
  187.     case XLTYPE_PIPE:
  188.         putatm(fptr, "Pipe-Stream", vptr);
  189.         break;
  190. #endif /* (defined(UNIX) || defined(WINTERP)) */
  191.  
  192.     default:
  193.         putatm(fptr,"Foo",vptr);
  194.         break;
  195.     }
  196. }
  197.  
  198. /* xlterpri - terminate the current print line */
  199. xlterpri(fptr)
  200.   LVAL fptr;
  201. {
  202.     xlputc(fptr,'\n');
  203. }
  204.  
  205. /* xlputstr - output a string */
  206. xlputstr(fptr,str)
  207.   LVAL fptr; char *str;
  208. {
  209.     while (*str)
  210.     xlputc(fptr,*str++);
  211. }
  212.  
  213. /* putsymbol - output a symbol */
  214. LOCAL putsymbol(fptr,str,escflag)
  215.   LVAL fptr; char *str; int escflag;
  216. {
  217.     int downcase,ch;
  218.     LVAL type;
  219.     char *p;
  220.  
  221.     /* check for printing without escapes */
  222.     if (!escflag) {
  223.     xlputstr(fptr,str);
  224.     return;
  225.     }
  226.  
  227.     /* check to see if symbol needs escape characters */
  228.     if (tentry(*str) == k_const) {
  229.     for (p = str; *p; ++p)
  230.         if (islower(*p)
  231.         ||  ((type = tentry(*p)) != k_const
  232.           && (!consp(type) || car(type) != k_nmacro))) {
  233.         xlputc(fptr,'|');
  234.         while (*str) {
  235.             if (*str == '\\' || *str == '|')
  236.             xlputc(fptr,'\\');
  237.             xlputc(fptr,*str++);
  238.         }
  239.         xlputc(fptr,'|');
  240.         return;
  241.         }
  242.     }
  243.  
  244.     /* get the case translation flag */
  245.     downcase = (getvalue(s_printcase) == k_downcase);
  246.  
  247.     /* check for the first character being '#' */
  248.     if (*str == '#' || *str == '.' || isnumber(str,NULL))
  249.     xlputc(fptr,'\\');
  250.  
  251.     /* output each character */
  252.     while ((ch = *str++) != '\0') {
  253.     /* don't escape colon until we add support for packages */
  254.     if (ch == '\\' || ch == '|' /* || ch == ':' */)
  255.         xlputc(fptr,'\\');
  256.     xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
  257.     }
  258. }
  259.  
  260. /* putstring - output a string */
  261. LOCAL putstring(fptr,str)
  262.   LVAL fptr,str;
  263. {
  264.     unsigned char *p;
  265.     int ch;
  266.  
  267.     /* output each character */
  268.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  269.     xlputc(fptr,ch);
  270. }
  271.  
  272. /* putqstring - output a quoted string */
  273. LOCAL putqstring(fptr,str)
  274.   LVAL fptr,str;
  275. {
  276.     unsigned char *p;
  277.     int ch;
  278.  
  279.     /* get the string pointer */
  280.     p = getstring(str);
  281.  
  282.     /* output the initial quote */
  283.     xlputc(fptr,'"');
  284.  
  285.     /* output each character in the string */
  286.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  287.  
  288.     /* check for a control character */
  289.     if (ch < 040 || ch == '\\' || ch > 0176) {
  290.         xlputc(fptr,'\\');
  291.         switch (ch) {
  292.         case '\011':
  293.             xlputc(fptr,'t');
  294.             break;
  295.         case '\012':
  296.             xlputc(fptr,'n');
  297.             break;
  298.         case '\014':
  299.             xlputc(fptr,'f');
  300.             break;
  301.         case '\015':
  302.             xlputc(fptr,'r');
  303.             break;
  304.         case '\\':
  305.             xlputc(fptr,'\\');
  306.             break;
  307.         default:
  308.             putoct(fptr,ch);
  309.             break;
  310.         }
  311.     }
  312.  
  313.     /* output a normal character */
  314.     else
  315.         xlputc(fptr,ch);
  316.  
  317.     /* output the terminating quote */
  318.     xlputc(fptr,'"');
  319. }
  320.  
  321. /* putatm - output an atom */
  322. LOCAL putatm(fptr,tag,val)
  323.   LVAL fptr; char *tag; LVAL val;
  324. {
  325.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  326.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  327.     xlputc(fptr,'>');
  328. }
  329.  
  330. /* putsubr - output a subr/fsubr */
  331. LOCAL putsubr(fptr,tag,val)
  332.   LVAL fptr; char *tag; LVAL val;
  333. {
  334.     sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
  335.     xlputstr(fptr,buf);
  336.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  337.     xlputc(fptr,'>');
  338. }
  339.  
  340. /* putclosure - output a closure */
  341. LOCAL putclosure(fptr,val)
  342.   LVAL fptr,val;
  343. {
  344.     LVAL name;
  345.     if (name = getname(val))
  346.     sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
  347.     else
  348.     strcpy(buf,"#<Closure: #");
  349.     xlputstr(fptr,buf);
  350.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  351.     xlputc(fptr,'>');
  352. /*
  353.     xlputstr(fptr,"\nName:   "); xlprint(fptr,getname(val),TRUE);
  354.     xlputstr(fptr,"\nType:   "); xlprint(fptr,gettype(val),TRUE);
  355.     xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
  356.     xlputstr(fptr,"\nArgs:   "); xlprint(fptr,getargs(val),TRUE);
  357.     xlputstr(fptr,"\nOargs:  "); xlprint(fptr,getoargs(val),TRUE);
  358.     xlputstr(fptr,"\nRest:   "); xlprint(fptr,getrest(val),TRUE);
  359.     xlputstr(fptr,"\nKargs:  "); xlprint(fptr,getkargs(val),TRUE);
  360.     xlputstr(fptr,"\nAargs:  "); xlprint(fptr,getaargs(val),TRUE);
  361.     xlputstr(fptr,"\nBody:   "); xlprint(fptr,getbody(val),TRUE);
  362.     xlputstr(fptr,"\nEnv:    "); xlprint(fptr,getenv(val),TRUE);
  363.     xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
  364. */
  365. }
  366.  
  367. /* putfixnum - output a fixnum */
  368. LOCAL putfixnum(fptr,n)
  369.   LVAL fptr; FIXTYPE n;
  370. {
  371.     char *fmt;            /* NPM: changed from unsigned char* to prevent compiler warning */
  372.     LVAL val;
  373.     fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? (char *) getstring(val)
  374.                             : (char *)IFMT);
  375.     sprintf(buf,fmt,n);
  376.     xlputstr(fptr,buf);
  377. }
  378.  
  379. /* putflonum - output a flonum */
  380. LOCAL putflonum(fptr,n)
  381.   LVAL fptr; FLOTYPE n;
  382. {
  383.     char *fmt;            /* NPM: changed from unsigned char* to prevent compiler warning */
  384.     LVAL val;
  385.     fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? (char *) getstring(val)
  386.                             : (char *)"%g");
  387.     sprintf(buf,fmt,n);
  388.     xlputstr(fptr,buf);
  389. }
  390.  
  391. /* putchcode - output a character */
  392. LOCAL putchcode(fptr,ch,escflag)
  393.   LVAL fptr; int ch,escflag;
  394. {
  395.     if (escflag) {
  396.     switch (ch) {
  397.     case '\n':
  398.         xlputstr(fptr,"#\\Newline");
  399.         break;
  400.     case ' ':
  401.         xlputstr(fptr,"#\\Space");
  402.         break;
  403.     default:
  404.         sprintf(buf,"#\\%c",ch);
  405.         xlputstr(fptr,buf);
  406.         break;
  407.     }
  408.     }
  409.     else
  410.     xlputc(fptr,ch);
  411. }
  412.  
  413. /* putoct - output an octal byte value */
  414. LOCAL putoct(fptr,n)
  415.   LVAL fptr; int n;
  416. {
  417.     sprintf(buf,"%03o",n);
  418.     xlputstr(fptr,buf);
  419. }
  420.